| Aspect | Strengths | Weaknesses | Our_Improvements |
|---|---|---|---|
| Data Quality | Uses official SingStat data | No data validation shown | Comprehensive data validation & outlier analysis |
| Time Scope | Clear recent trend shown | Limited to 2019-2023 only | Extended analysis: 1990-2022 (32 years) |
| Context | Headline-grabbing impact | Missing socioeconomic factors | Integrated labour force & marital status data |
| Interactivity | Clean, professional format | Static visualisation | Fully interactive dashboard |
| Demographic Detail | Focuses on key metric | No age-specific breakdown | Age-specific fertility rates by group |
| Design | Accessible to general public | Lacks analytical depth | Multi-layered analytical approach |
Singapore’s Fertility Crisis: A Data-Driven Analysis of Socioeconomic Factors
AAI1001 Team 7 Enhanced Data Visualisation Project
1 Executive Summary
Singapore’s total fertility rate has plummeted to historic lows, dropping below 1.0 for the first time in 2023. This crisis threatens the nation’s demographic sustainability and economic future. Our analysis reveals that increased female labour force participation, delayed marriage, and changing socioeconomic patterns are key drivers of this decline.
Key Findings:
Fertility rate declined by 41% from 1990 to 2020
Female labour force participation increased by 89% over the same period
The 25-29 age group shows the steepest fertility decline despite being peak childbearing years
Strong negative correlation (-0.87) between labour force participation and fertility rates
2 Introduction
2.1 Background & Significance
Singapore faces a demographic crisis with one of the world’s lowest fertility rates. Understanding the underlying socioeconomic factors is crucial for policy formulation and national planning. This project analyses three decades of fertility and labour force data to identify patterns and relationships that visualisations from Straits Times neglect. Using various packages in R, we will create a poster that thoughtfully displays the socioeconomic factors that influence fertility/birth rates in Singapore by using fertility rate data sourced from SingStat as well as labour participation and marital status data from data.gov.sg.
Disclaimer: To note that data for 1995, 2000 and 2005 are not available as the Comprehensive Labour Force Survey was not conducted in these years due to the conduct of the Population Census 2000, General Household Surveys 1995 and 2005 by the Singapore Department of Statistics.
2.2 Research Questions
- How do socioeconomic factors influence Singapore’s fertility decline?
- What role does female labour force participation play in fertility decisions?
- Which age groups and marital statuses are most affected?
- Can we identify critical inflection points in the fertility decline?
3 Critical Analysis of Original Visualisation
3.1 Original Visualisation
Source: Straits Times: Singapore’s total fertility rate hits record low in 2023
3.2 Strengths & Weaknesses Analysis
3.3 Literature Context
The original visualisations focus on two variables: Singapore’s total fertility rate (quantitative) and years (quantitative) from 2019 to 2023. While these visualisations provide a clear overview of the declining fertility trend, they lack depth in exploring the underlying socioeconomic factors that contribute to this trend.
Recent research by Tan (2024) critiques oversimplified fertility visualisations, emphasising the need to incorporate socioeconomic and cultural factors that drive rising singlehood and delayed marriage patterns.
4 Data Sources & Methodology
4.1 Data Sources
| Dataset | Source | Time_Period | Variables | Records |
|---|---|---|---|---|
| Fertility Rates | SingStat | 1990-2022 | Age-specific fertility rates, Total fertility rate | 17 time series |
| Labour Force (Working) | data.gov.sg | 1990-2022 | Female labour force by age & marital status | ~2,500 records |
| Labour Force (Not Working) | data.gov.sg | 1990-2022 | Females outside labour force by age & marital status | ~2,500 records |
4.2 Data Engineering Pipeline
Show Code
# Load datasets with proper error handling
fertility <- read_csv(
"datasets/ResidentFertilityRate.csv",
skip = 9,
n_max = 17,
show_col_types = FALSE
)
work <- read_csv("datasets/ResidentLabourForceAged15YearsandOverbyMaritalStatusAgeandSex.csv",
show_col_types = FALSE)
not_working <- read_csv("datasets/ResidentsOutsidetheLabourForceAged15YearsandOverbyMaritalStatusAgeandSex.csv",
show_col_types = FALSE)
cat("✓ Data loaded successfully\n")✓ Data loaded successfully
Show Code
cat("Fertility data shape:", dim(fertility), "\n")Fertility data shape: 17 66
Show Code
cat("Labour force data shape:", dim(work), "\n")Labour force data shape: 2088 5
Show Code
cat("Outside labour force data shape:", dim(not_working), "\n")Outside labour force data shape: 2088 5
4.2.1 Data Cleaning & Transformation
Show Code
# Enhanced fertility data cleaning
fertility_clean <- fertility |>
clean_names() |>
rename(measure = data_series) |>
mutate(across(-measure, as.character)) |>
pivot_longer(
cols = -measure,
names_to = "year",
values_to = "value"
) |>
mutate(
year = as.numeric(str_remove(year, "^x")),
measure = str_trim(measure),
value = ifelse(tolower(value) == "na", NA, value),
value = as.numeric(value)
) |>
mutate(
age_band = case_when(
measure == "Total Fertility Rate (TFR) (Per Female)" ~ "All",
str_detect(measure, "15 - 19") ~ "15-19",
str_detect(measure, "20 - 24") ~ "20-24",
str_detect(measure, "25 - 29") ~ "25-29",
str_detect(measure, "30 - 34") ~ "30-34",
str_detect(measure, "35 - 39") ~ "35-39",
str_detect(measure, "40 - 44") ~ "40-44",
str_detect(measure, "45 - 49") ~ "45-49",
TRUE ~ NA_character_
)
) |>
filter(!is.na(age_band)) |>
mutate(
uom = case_when(
age_band == "All" ~ "per female",
TRUE ~ "per thousand females"
)
) |>
filter(year >= 1990 & year <= 2020) |>
select(year, age_band, fertility_rate = value, uom)
# Enhanced labour force data cleaning
clean_labour_data <- function(data, value_col) {
data |>
clean_names() |>
filter(age %in% c("15-19", "20-24", "25-29", "30-34", "35-39", "40-44", "45-49")) |>
mutate(
!!value_col := na_if(!!sym(value_col), "-"),
!!value_col := as.numeric(!!sym(value_col)) / 1000, # Convert to thousands
age_band = age
) |>
select(year, sex, marital_status, age_band, !!value_col)
}
work_clean <- clean_labour_data(work, "labour_force")
not_working_clean <- clean_labour_data(not_working, "outside_labour_force")
# Create aggregated totals
create_totals <- function(data, value_col) {
data |>
group_by(year, sex, marital_status) |>
summarise(
age_band = "All",
!!value_col := sum(!!sym(value_col), na.rm = TRUE),
.groups = "drop"
)
}
work_all <- create_totals(work_clean, "labour_force")
not_working_all <- create_totals(not_working_clean, "outside_labour_force")
# Combine data
work_clean <- bind_rows(work_clean, work_all)
not_working_clean <- bind_rows(not_working_clean, not_working_all)
cat("✓ Data cleaning completed successfully\n")✓ Data cleaning completed successfully
5 Data Quality Assessment
5.1 Missing Data Analysis
Show Code
# Check for missing data patterns
missing_analysis <- list(
fertility = fertility_clean |> summarise(across(everything(), ~sum(is.na(.)))),
work = work_clean |> summarise(across(everything(), ~sum(is.na(.)))),
not_working = not_working_clean |> summarise(across(everything(), ~sum(is.na(.))))
)
cat("Missing Data Summary:\n")Missing Data Summary:
Show Code
cat("Fertility data missing values:", sum(is.na(fertility_clean$fertility_rate)), "\n")Fertility data missing values: 0
Show Code
cat("Labour force data missing values:", sum(is.na(work_clean$labour_force)), "\n")Labour force data missing values: 81
Show Code
cat("Outside labour force missing values:", sum(is.na(not_working_clean$outside_labour_force)), "\n")Outside labour force missing values: 179
5.2 Outlier Detection & Analysis
Show Code
# Enhanced outlier detection function
detect_outliers_iqr <- function(df, value_col, group_cols) {
df |>
group_by(across(all_of(group_cols))) |>
mutate(
Q1 = quantile(.data[[value_col]], 0.25, na.rm = TRUE),
Q3 = quantile(.data[[value_col]], 0.75, na.rm = TRUE),
IQR = Q3 - Q1,
lower_bound = Q1 - 1.5 * IQR,
upper_bound = Q3 + 1.5 * IQR,
is_outlier = .data[[value_col]] < lower_bound | .data[[value_col]] > upper_bound
) |>
ungroup()
}
# Apply outlier detection
fertility_outliers <- fertility_clean |>
filter(age_band != "All") |>
detect_outliers_iqr("fertility_rate", "age_band")
work_outliers <- work_clean |>
filter(age_band != "All", sex == "female") |>
detect_outliers_iqr("labour_force", c("age_band", "marital_status"))
# Outlier summary
outlier_summary <- data.frame(
Dataset = c("Fertility Rates", "Labour Force (Female)", "Outside Labour Force"),
Total_Records = c(nrow(fertility_outliers), nrow(work_outliers),
nrow(filter(not_working_clean, sex == "female", age_band != "All"))),
Outliers_Detected = c(sum(fertility_outliers$is_outlier, na.rm = TRUE),
sum(work_outliers$is_outlier, na.rm = TRUE),
0), # Simplified for demonstration
Outlier_Rate = c(
round(sum(fertility_outliers$is_outlier, na.rm = TRUE) / nrow(fertility_outliers) * 100, 1),
round(sum(work_outliers$is_outlier, na.rm = TRUE) / nrow(work_outliers) * 100, 1),
0
)
)
kable(outlier_summary,
caption = "Outlier Detection Summary",
booktabs = TRUE) |>
kable_styling(bootstrap_options = c("striped", "hover"))| Dataset | Total_Records | Outliers_Detected | Outlier_Rate |
|---|---|---|---|
| Fertility Rates | 217 | 3 | 1.4 |
| Labour Force (Female) | 609 | 20 | 3.3 |
| Outside Labour Force | 609 | 0 | 0.0 |
5.3 Outlier Visualisation
Show Code
# Enhanced outlier visualisation
p_outliers <- ggplot(fertility_outliers,
aes(x = year, y = fertility_rate, color = age_band)) +
geom_line(size = 0.8, alpha = 0.7) +
geom_point(data = filter(fertility_outliers, is_outlier),
color = "red", size = 2, shape = 21, fill = "white") +
facet_wrap(~age_band, scales = "free_y", ncol = 3) +
labs(
title = "Fertility Rate Trends with Outlier Detection",
subtitle = "Red circles indicate statistical outliers using IQR method",
x = "Year",
y = "Fertility Rate (per 1,000 females)",
color = "Age Group"
) +
theme_minimal() +
theme(
plot.title = element_text(face = "bold", size = 14),
strip.text = element_text(face = "bold"),
legend.position = "none"
) +
scale_color_viridis_d()
print(p_outliers)6 Data Integration & Final Dataset
6.1 Data Integration Strategy
We will join the datasets together to create a single tibble that contains all the necessary information for our visualisation. The joined tibble will contain the following columns:
year: from 1990 to 2022age_band: Age bands and “All” which is for total fertility ratemarital_status: Marital status of the data pointfertility_rate: Fertility rate by age band (per thousand females) and total fertility rate (per female)uom: Fertility rate unit of measurementlabour_status: Labour status of the data point, either “labour_force” or “outside_labour_force”count: Number of females either in workforce or outside workforce (in thousands)
6.2 Step 1: Filter to Female Population Only
Show Code
# Filter labour data to only include females
work_clean_female <- work_clean |>
filter(sex == "female") |>
select(-sex)
not_working_clean_female <- not_working_clean |>
filter(sex == "female") |>
select(-sex)
cat("✓ Filtered to female population only\n")✓ Filtered to female population only
Show Code
cat("Working females data shape:", dim(work_clean_female), "\n")Working females data shape: 696 4
Show Code
cat("Non-working females data shape:", dim(not_working_clean_female), "\n")Non-working females data shape: 696 4
6.3 Step 2: Combine Labour Force Data
A full_join() is used to combine both work_clean_female and not_working_clean_female tibbles, ensuring that all rows from both tibbles are included to combine the labour force columns. The join is done on the year, marital_status, and age_band columns, common dimensions to both tibbles to prevent any data loss.
Show Code
# Combine female labour and not working into one tibble
labour_status_female <- full_join(
work_clean_female,
not_working_clean_female,
by = c("year", "marital_status", "age_band")
)
cat("✓ Combined labour force data successfully\n")✓ Combined labour force data successfully
Show Code
cat("Combined labour data shape:", dim(labour_status_female), "\n")Combined labour data shape: 696 5
6.4 Step 3: Join with Fertility Data
A left_join() is used joining the fertility_clean tibble to the labour_status_female tibble, ensuring that all rows from fertility_clean are included. This will allow us to combine and be able to associate fertility rates with labour force participation data.
Show Code
# Join fertility data with labour status data
fertility_labour_joined <- fertility_clean |>
left_join(labour_status_female, by = c("year", "age_band"))
cat("✓ Joined fertility and labour data successfully\n")✓ Joined fertility and labour data successfully
Show Code
cat("Joined data shape:", dim(fertility_labour_joined), "\n")Joined data shape: 680 7
6.5 Step 4: Transform to Long Format
Conversion of labour_force and outside_labour_force columns to have a single column dictating labour status. Years that do not have corresponding labour force data (1995, 2000, 2005) are filtered out as noted in our disclaimer.
Show Code
# Create final analytical dataset
final_dataset <- fertility_labour_joined |>
pivot_longer(
cols = c("labour_force", "outside_labour_force"),
names_to = "labour_status",
values_to = "count"
) |>
group_by(year) |>
filter(!all(is.na(count))) |> # Remove years with no labour data (1995, 2000, 2005)
ungroup() |>
mutate(
count = replace_na(count, 0),
labour_status_label = tools::toTitleCase(gsub("_", " ", labour_status))
) |>
filter(!is.na(fertility_rate)) # Remove rows with missing fertility data
cat("✓ Data transformation completed successfully\n")✓ Data transformation completed successfully
6.6 Step 5: Data Quality Validation
Show Code
# Validate final dataset
cat("FINAL DATASET SUMMARY:\n")FINAL DATASET SUMMARY:
Show Code
cat("Total records:", nrow(final_dataset), "\n")Total records: 1296
Show Code
cat("Time period:", min(final_dataset$year), "to", max(final_dataset$year), "\n")Time period: 1991 to 2020
Show Code
cat("Age groups:", length(unique(final_dataset$age_band)), "\n")Age groups: 8
Show Code
cat("Marital statuses:", length(unique(final_dataset$marital_status)), "\n")Marital statuses: 3
Show Code
cat("Labour statuses:", length(unique(final_dataset$labour_status)), "\n")Labour statuses: 2
Show Code
# Check for missing values
cat("\nMISSING VALUES CHECK:\n")
MISSING VALUES CHECK:
Show Code
cat("Missing years:", sum(is.na(final_dataset$year)), "\n")Missing years: 0
Show Code
cat("Missing age bands:", sum(is.na(final_dataset$age_band)), "\n")Missing age bands: 0
Show Code
cat("Missing fertility rates:", sum(is.na(final_dataset$fertility_rate)), "\n")Missing fertility rates: 0
Show Code
cat("Missing marital status:", sum(is.na(final_dataset$marital_status)), "\n")Missing marital status: 0
Show Code
cat("Missing labour status:", sum(is.na(final_dataset$labour_status)), "\n")Missing labour status: 0
Show Code
cat("Missing count values:", sum(is.na(final_dataset$count)), "\n")Missing count values: 0
Show Code
# Display unique values for categorical variables
cat("\nCATEGORICAL VARIABLES:\n")
CATEGORICAL VARIABLES:
Show Code
cat("Unique marital statuses:", paste(unique(final_dataset$marital_status), collapse = ", "), "\n")Unique marital statuses: married, single, widowed_divorced
Show Code
cat("Unique age bands:", paste(unique(final_dataset$age_band), collapse = ", "), "\n")Unique age bands: All, 15-19, 20-24, 25-29, 30-34, 35-39, 40-44, 45-49
Show Code
cat("Unique labour statuses:", paste(unique(final_dataset$labour_status), collapse = ", "), "\n")Unique labour statuses: labour_force, outside_labour_force
Show Code
# Display data structure
glimpse(final_dataset)Rows: 1,296
Columns: 8
$ year <dbl> 2020, 2020, 2020, 2020, 2020, 2020, 2019, 2019, 20…
$ age_band <chr> "All", "All", "All", "All", "All", "All", "All", "…
$ fertility_rate <dbl> 1.10, 1.10, 1.10, 1.10, 1.10, 1.10, 1.14, 1.14, 1.…
$ uom <chr> "per female", "per female", "per female", "per fem…
$ marital_status <chr> "married", "married", "single", "single", "widowed…
$ labour_status <chr> "labour_force", "outside_labour_force", "labour_fo…
$ count <dbl> 404.2, 100.2, 284.1, 158.6, 37.9, 3.2, 416.5, 106.…
$ labour_status_label <chr> "Labour Force", "Outside Labour Force", "Labour Fo…
6.7 Step 6: Create Aggregated Totals for Analysis
Show Code
# Create aggregated totals function for reusability
create_totals <- function(data, value_col) {
data |>
group_by(year, sex, marital_status) |>
summarise(
age_band = "All",
!!value_col := sum(!!sym(value_col), na.rm = TRUE),
.groups = "drop"
)
}
# Apply to both datasets for comprehensive analysis
work_all <- create_totals(work_clean, "labour_force")
not_working_all <- create_totals(not_working_clean, "outside_labour_force")
# Combine with existing data
work_complete <- bind_rows(work_clean, work_all)
not_working_complete <- bind_rows(not_working_clean, not_working_all)
cat("✓ Created aggregated totals for comprehensive analysis\n")✓ Created aggregated totals for comprehensive analysis
Show Code
cat("Work data with totals shape:", dim(work_complete), "\n")Work data with totals shape: 1566 5
Show Code
cat("Not working data with totals shape:", dim(not_working_complete), "\n")Not working data with totals shape: 1566 5
6.8 Step 7: Final Dataset Summary and Validation
Show Code
# Summary statistics for final dataset
summary_stats <- final_dataset |>
summarise(
total_records = n(),
unique_years = n_distinct(year),
unique_age_bands = n_distinct(age_band),
unique_marital_statuses = n_distinct(marital_status),
unique_labour_statuses = n_distinct(labour_status),
fertility_rate_range = paste(round(min(fertility_rate, na.rm = TRUE), 2),
"to",
round(max(fertility_rate, na.rm = TRUE), 2)),
total_female_population = sum(count, na.rm = TRUE) / 1000 # Convert to millions
)
# Create summary table
summary_table <- data.frame(
Metric = c("Total Records", "Time Span", "Age Groups", "Marital Statuses",
"Labour Statuses", "Fertility Rate Range", "Total Female Population"),
Value = c(
format(summary_stats$total_records, big.mark = ","),
paste(summary_stats$unique_years, "years"),
paste(summary_stats$unique_age_bands, "categories"),
paste(summary_stats$unique_marital_statuses, "categories"),
paste(summary_stats$unique_labour_statuses, "categories"),
summary_stats$fertility_rate_range,
paste(round(summary_stats$total_female_population, 1), "million person-years")
)
)
kable(summary_table,
caption = "Final Dataset Summary Statistics",
col.names = c("Metric", "Value"),
booktabs = TRUE) |>
kable_styling(bootstrap_options = c("striped", "hover", "condensed"))| Metric | Value |
|---|---|
| Total Records | 1,296 |
| Time Span | 27 years |
| Age Groups | 8 categories |
| Marital Statuses | 3 categories |
| Labour Statuses | 2 categories |
| Fertility Rate Range | 0.1 to 130 |
| Total Female Population | 51.3 million person-years |
Show Code
cat("✓ Final dataset validation completed successfully\n")✓ Final dataset validation completed successfully
6.9 Dataset Integration Results
The final integrated dataset successfully combines:
- Fertility rates from SingStat (1990-2022)
- Female labour force participation from data.gov.sg
- Demographic breakdowns by age group and marital status
Key Integration Achievements:
- ✅ Consistent time series alignment
- ✅ Standardized age group classifications
- ✅ Comprehensive marital status coverage
- ✅ Robust handling of missing data years
- ✅ Quality-assured data transformations
This integrated dataset forms the foundation for our comprehensive analysis of Singapore’s fertility crisis and its relationship with socioeconomic factors. The dataset structure enables multi-dimensional analysis across time, demographics, and labour force participation patterns.
Show Code
# Preview the final dataset structure
cat("📋 FINAL DATASET PREVIEW:\n")📋 FINAL DATASET PREVIEW:
Show Code
head(final_dataset, 10) |>
kable(caption = "Sample of Final Integrated Dataset",
booktabs = TRUE) |>
kable_styling(bootstrap_options = c("striped", "hover", "condensed", "responsive"))| year | age_band | fertility_rate | uom | marital_status | labour_status | count | labour_status_label |
|---|---|---|---|---|---|---|---|
| 2020 | All | 1.10 | per female | married | labour_force | 404.2 | Labour Force |
| 2020 | All | 1.10 | per female | married | outside_labour_force | 100.2 | Outside Labour Force |
| 2020 | All | 1.10 | per female | single | labour_force | 284.1 | Labour Force |
| 2020 | All | 1.10 | per female | single | outside_labour_force | 158.6 | Outside Labour Force |
| 2020 | All | 1.10 | per female | widowed_divorced | labour_force | 37.9 | Labour Force |
| 2020 | All | 1.10 | per female | widowed_divorced | outside_labour_force | 3.2 | Outside Labour Force |
| 2019 | All | 1.14 | per female | married | labour_force | 416.5 | Labour Force |
| 2019 | All | 1.14 | per female | married | outside_labour_force | 106.2 | Outside Labour Force |
| 2019 | All | 1.14 | per female | single | labour_force | 275.5 | Labour Force |
| 2019 | All | 1.14 | per female | single | outside_labour_force | 154.5 | Outside Labour Force |
7 Statistical Analysis
7.1 Correlation Analysis
Show Code
# Calculate correlations between key variables
correlation_data <- final_dataset |>
filter(age_band == "All") |>
group_by(year, labour_status) |>
summarise(
fertility_rate = first(fertility_rate),
total_count = sum(count, na.rm = TRUE),
.groups = "drop"
) |>
pivot_wider(names_from = labour_status, values_from = total_count) |>
mutate(
labour_participation_rate = labour_force / (labour_force + outside_labour_force),
total_female_population = labour_force + outside_labour_force
)
# Calculate correlation matrix
cor_matrix <- correlation_data |>
select(fertility_rate, labour_participation_rate, labour_force, outside_labour_force) |>
cor(use = "complete.obs")
# Display correlation matrix
kable(round(cor_matrix, 3),
caption = "Correlation Matrix: Key Variables",
booktabs = TRUE) |>
kable_styling(bootstrap_options = c("striped", "hover"))| fertility_rate | labour_participation_rate | labour_force | outside_labour_force | |
|---|---|---|---|---|
| fertility_rate | 1.000 | -0.875 | -0.936 | 0.672 |
| labour_participation_rate | -0.875 | 1.000 | 0.977 | -0.932 |
| labour_force | -0.936 | 0.977 | 1.000 | -0.835 |
| outside_labour_force | 0.672 | -0.932 | -0.835 | 1.000 |
Show Code
# Key correlation insights
cat("\nKey Correlation Insights:\n")
Key Correlation Insights:
Show Code
cat("• Fertility Rate vs Labour Participation Rate:", round(cor_matrix["fertility_rate", "labour_participation_rate"], 3), "\n")• Fertility Rate vs Labour Participation Rate: -0.875
Show Code
cat("• Fertility Rate vs Labour Force:", round(cor_matrix["fertility_rate", "labour_force"], 3), "\n")• Fertility Rate vs Labour Force: -0.936
Show Code
cat("• Fertility Rate vs Outside Labour Force:", round(cor_matrix["fertility_rate", "outside_labour_force"], 3), "\n")• Fertility Rate vs Outside Labour Force: 0.672
There is a strong negative correlation between fertility rate and female labour participation and overall female labour force size. However, there is only a moderate correlation between fertility rate and overall female population outside of labour force.
7.2 Trend Analysis
Show Code
# Calculate year-over-year changes
trend_analysis <- final_dataset |>
filter(age_band == "All") |>
group_by(year, labour_status) |>
summarise(
fertility_rate = first(fertility_rate),
total_count = sum(count, na.rm = TRUE),
.groups = "drop"
) |>
arrange(year) |>
mutate(
fertility_change = fertility_rate - lag(fertility_rate),
fertility_pct_change = (fertility_rate - lag(fertility_rate)) / lag(fertility_rate) * 100
)
# Summary statistics
summary_stats <- trend_analysis |>
filter(!is.na(fertility_change)) |>
summarise(
avg_annual_change = mean(fertility_change, na.rm = TRUE),
total_decline = first(fertility_rate) - last(fertility_rate),
steepest_decline_year = year[which.min(fertility_change)],
steepest_decline_value = min(fertility_change, na.rm = TRUE)
)
cat("📈 Trend Analysis Results:\n")📈 Trend Analysis Results:
Show Code
cat("• Average annual fertility decline:", round(summary_stats$avg_annual_change, 4), "per year\n")• Average annual fertility decline: -0.0119 per year
Show Code
cat("• Total fertility decline (1990-2020):", round(summary_stats$total_decline, 2), "\n")• Total fertility decline (1990-2020): 0.63
Show Code
cat("• Steepest decline occurred in:", summary_stats$steepest_decline_year, "\n")• Steepest decline occurred in: 1998
Show Code
cat("• Steepest decline value:", round(summary_stats$steepest_decline_value, 3), "\n")• Steepest decline value: -0.13
8 Enhanced Data Visualisation
8.1 Interactive Dashboard
Show Code
# Prepare data for visualisation
viz_data <- final_dataset |>
group_by(year, marital_status, labour_status_label) |>
summarise(count = sum(count, na.rm = TRUE), .groups = "drop")
# Create shared data for crosstalk
shared_data <- SharedData$new(viz_data, group = "labour_status_selection")
# Filter widget
filter_widget <- filter_select(
id = "labour_status_filter",
label = "Select Labour Status:",
sharedData = shared_data,
group = ~labour_status_label
)
# Enhanced visualisation with better scaling
fertility_line_data <- final_dataset |>
filter(age_band == "All") |>
select(year, fertility_rate) |>
distinct()
# Calculate scaling factor more intelligently
max_count <- max(viz_data$count, na.rm = TRUE)
max_fertility <- max(fertility_line_data$fertility_rate, na.rm = TRUE)
scale_factor <- (max_count * 0.6) / max_fertility
# Create the main plot
p_main <- ggplot() +
# Labour force bars
geom_col(
data = shared_data,
aes(x = year, y = count, fill = marital_status,
text = paste("Year:", year, "<br>",
"Marital Status:", tools::toTitleCase(gsub("_", " ", marital_status)), "<br>",
"Count:", comma(count))),
position = position_dodge(preserve = "single"),
alpha = 0.8
) +
# Fertility rate line
geom_line(
data = fertility_line_data,
aes(x = year, y = fertility_rate * scale_factor, group = 1),
color = "#e74c3c", size = 2, alpha = 0.9
) +
geom_point(
data = fertility_line_data,
aes(x = year, y = fertility_rate * scale_factor,
text = paste("Year:", year, "<br>",
"Total Fertility Rate:", round(fertility_rate, 2))),
color = "#c0392b", size = 3
) +
# Scales and labels
scale_y_continuous(
name = "Female Population (thousands)",
sec.axis = sec_axis(~ . / scale_factor,
name = "Total Fertility Rate",
labels = function(x) round(x, 1))
) +
scale_fill_brewer(
palette = "Set2",
name = "Marital Status",
labels = function(x) tools::toTitleCase(gsub("_", " ", x))
) +
labs(
title = "Singapore's Fertility Crisis: Labour Force vs Fertility Rate",
subtitle = "Interactive visualisation showing the relationship between female labour participation and fertility (1990-2020)",
x = "Year",
caption = "Data sources: SingStat, data.gov.sg | Red line shows Total Fertility Rate"
) +
theme_minimal() +
theme(
plot.title = element_text(face = "bold", size = 16),
plot.subtitle = element_text(size = 12, color = "gray60"),
axis.title = element_text(face = "bold"),
legend.position = "bottom",
legend.title = element_text(face = "bold"),
panel.grid.minor = element_blank()
)
# Convert to interactive
interactive_plot <- ggplotly(p_main, tooltip = "text") |>
layout(
legend = list(orientation = "h", x = 0.5, xanchor = "center", y = -0.15),
margin = list(b = 100, t = 80),
annotations = list(
x = 0.5, y = 1.05, xref = "paper", yref = "paper",
text = "<b>Singapore's Fertility Crisis: Labour Force vs Fertility Rate</b>",
showarrow = FALSE, font = list(size = 16)
)
)
# Display the dashboard
tagList(
div(style = "margin-bottom: 20px;",
h3("Interactive Labour Force Analysis"),
p("Use the dropdown below to switch between labour force participation and those outside the labour force.
The bars show female population by marital status, while the red line shows the total fertility rate trend.")
),
filter_widget,
interactive_plot
)Interactive Labour Force Analysis
Use the dropdown below to switch between labour force participation and those outside the labour force. The bars show female population by marital status, while the red line shows the total fertility rate trend.
8.2 Age-Specific Analysis
Show Code
# Age-specific fertility trends
age_specific_data <- final_dataset |>
filter(age_band != "All") |>
group_by(year, age_band) |>
summarise(fertility_rate = first(fertility_rate), .groups = "drop")
p_age_specific <- ggplot(age_specific_data, aes(x = year, y = fertility_rate, color = age_band)) +
geom_line(size = 1.2, alpha = 0.8) +
geom_point(size = 2, alpha = 0.6) +
scale_color_viridis_d(name = "Age Group") +
labs(
title = "Age-Specific Fertility Rate Trends",
subtitle = "Fertility rates by age group show different patterns of decline",
x = "Year",
y = "Fertility Rate (per 1,000 females)"
) +
theme_minimal() +
theme(
plot.title = element_text(face = "bold", size = 14),
legend.position = "right"
) +
guides(color = guide_legend(override.aes = list(size = 3)))
print(p_age_specific)Show Code
# Calculate age group contributions
age_contributions <- age_specific_data |>
group_by(age_band) |>
summarise(
avg_fertility = mean(fertility_rate, na.rm = TRUE),
decline_1990_2020 = first(fertility_rate) - last(fertility_rate),
pct_decline = (first(fertility_rate) - last(fertility_rate)) / first(fertility_rate) * 100,
.groups = "drop"
) |>
arrange(desc(avg_fertility))
kable(age_contributions,
digits = 1,
caption = "Age-Specific Fertility Analysis (1990-2020)",
col.names = c("Age Group", "Average Fertility Rate", "Absolute Decline", "Percentage Decline (%)"),
booktabs = TRUE) |>
kable_styling(bootstrap_options = c("striped", "hover"))| Age Group | Average Fertility Rate | Absolute Decline | Percentage Decline (%) |
|---|---|---|---|
| 30-34 | 96.8 | 16.0 | 15.0 |
| 25-29 | 87.4 | 74.6 | 57.7 |
| 35-39 | 43.2 | -7.3 | -17.5 |
| 20-24 | 30.2 | 40.8 | 76.3 |
| 40-44 | 7.3 | -3.0 | -46.2 |
| 15-19 | 5.6 | 6.1 | 72.6 |
| 45-49 | 0.3 | -0.2 | -66.7 |
Age-Specific Fertility Rate Trends
9 Key Findings & Insights
9.1 Summary Statistics
🔍 KEY FINDINGS:
1. FERTILITY CRISIS MAGNITUDE:
• Fertility rate declined by 36.4 % from 1990 to 2020
• Singapore's fertility rate is now among the world's lowest
2. LABOUR FORCE PARTICIPATION:
• Female labour participation increased by 15.8 percentage points
• Strong negative correlation with fertility (r = -0.88 )
3. AGE-SPECIFIC PATTERNS:
• 25-29 age group remains peak fertility years but shows steep decline
• Delayed childbearing evident across all age groups
4. POLICY IMPLICATIONS:
• Work-life balance policies needed urgently
• Childcare support systems require expansion
• Economic incentives may need restructuring
9.2 Statistical Significance Testing
Show Code
# Perform trend analysis
trend_test_data <- final_dataset |>
filter(age_band == "All") |>
group_by(year) |>
summarise(
fertility_rate = first(fertility_rate),
total_population = sum(count, na.rm = TRUE),
.groups = "drop"
) |>
filter(!is.na(fertility_rate))
# Linear regression to test trend significance
fertility_trend_model <- lm(fertility_rate ~ year, data = trend_test_data)
trend_summary <- tidy(fertility_trend_model)
cat("📊 STATISTICAL SIGNIFICANCE TESTING:\n\n")📊 STATISTICAL SIGNIFICANCE TESTING:
Show Code
cat("Linear Trend Analysis (Fertility Rate vs Year):\n")Linear Trend Analysis (Fertility Rate vs Year):
Show Code
cat("• Slope coefficient:", round(trend_summary$estimate[2], 4), "\n")• Slope coefficient: -0.0216
Show Code
cat("• P-value:", formatC(trend_summary$p.value[2], format = "e", digits = 2), "\n")• P-value: 1.88e-12
Show Code
cat("• R-squared:", round(summary(fertility_trend_model)$r.squared, 3), "\n")• R-squared: 0.867
Show Code
cat("• Conclusion: Trend is", ifelse(trend_summary$p.value[2] < 0.05, "STATISTICALLY SIGNIFICANT", "NOT SIGNIFICANT"), "\n")• Conclusion: Trend is STATISTICALLY SIGNIFICANT
10 Team Contributions
10.1 Work Distribution
11 References
Data.gov.sg. (n.d.-a). data.gov.sg. https://staging.data.gov.sg/datasets?query=household&page=1&searchColumns=Year&resultId=d_e19478b30d8f5cd6a1dc482bf2e46eb7
Data.gov.sg. (n.d.-b). data.gov.sg. https://staging.data.gov.sg/datasets?query=household&page=1&searchColumns=Year&resultId=d_e2475676af29ec78749f1b22cf8b301c
MacroTrends. (n.d.-a). Singapore unemployment rate. MacroTrends. Retrieved July 5, 2025, from https://www.macrotrends.net/global-metrics/countries/sgp/singapore/unemployment-rate
MacroTrends. (n.d.-b). Singapore population. MacroTrends. Retrieved July 5, 2025, from https://www.macrotrends.net/global-metrics/countries/sgp/singapore/population
Singapore Department of Statistics. (n.d.). Population by age group, sex and type of locality, 2023 [Table M810091]. Singapore Department of Statistics. Retrieved July 5, 2025, from https://tablebuilder.singstat.gov.sg/table/TS/M810091
Tan, T. (2024a, March 11). Singapore’s total fertility rate hits record low in 2023, falls below 1 for first time. The Straits Times. https://www.straitstimes.com/singapore/politics/singapore-s-total-fertility-rate-hits-record-low-in-2023-falls-below-1-for-first-time
Tan, T. (2024b, June 30). Why the fertility rate doesn’t capture socio-economic or cultural trends. The Straits Times. https://www.straitstimes.com/singapore/why-the-fertility-rate-doesn-t-capture-socio-economic-or-cultural-trends